home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Systray_Ic2076807232007.psc / Systray Icon / cSystray.cls
Text File  |  2007-07-22  |  64KB  |  1,170 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cSystray"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '---------------------------------------------------------------------------------------
  15. ' Module    : cSystray
  16. ' DateTime  : 05/07/2007 17:48
  17. ' Author    : Cobein
  18. ' Mail      : cobein27@yahoo.com
  19. ' Purpose   : Systray icon wrapper.
  20. '           Note: There are more functions and events, but they are OS specifics (XP SP2,Vista), but I think
  21. '           this class have everything you need to work so, Im not gonna add any of them.
  22. '
  23. 'Updated: 7-7-7
  24. '       Added Balloon timeout
  25. '       Balloon Nosound
  26. '       Changed the recovery function thanks to LaVolpe
  27. '       Some bugs fixed
  28. '
  29. 'Updated: 11-7-7
  30. '       Major rewrite, additions and bug fixes, added support for windowless projects, class arrays
  31. '       windows 9x balloon, 3 new methods to load icons from resource files, from files and to
  32. '       extract them from dlls, exes. Fixed the balloontimeout and problems with popup menus.
  33. '
  34. 'Updated: 16-7-7
  35. '       Bug concerning recovery function fixed, if you are using the old version please replace it!
  36. '       Thanks to:
  37. '       LaVolpe, Carlos Alberto S. and Body_of_Rays for bug reports, ideas, code samples and support.
  38. '---------------------------------------------------------------------------------------
  39. Option Explicit
  40.  
  41. '=======================================================================================
  42. ' Self subclass and callback declarations
  43. ' I removed the comments and unused constants (original code txtCodeId=68737)
  44. '=======================================================================================
  45. Private z_IDEflag           As Long         'Flag indicating we are in IDE
  46. Private z_ScMem             As Long         'Thunk base address
  47. Private z_scFunk            As Collection   'hWnd/thunk-address collection
  48. Private z_hkFunk            As Collection   'hook/thunk-address collection
  49. Private z_cbFunk            As Collection   'callback/thunk-address collection
  50. Private Const IDX_INDEX     As Long = 2     'index of the subclassed hWnd OR hook type
  51. Private Const IDX_CALLBACKORDINAL As Long = 22 ' Ubound(callback thunkdata)+1, index of the callback
  52.  
  53. ' Declarations:
  54. Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
  55. Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
  56. Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
  57. Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
  58. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
  59. Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
  60. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  61.  
  62. Private Enum eThunkType
  63.     SubclassThunk = 0
  64.     HookThunk = 1
  65.     CallbackThunk = 2
  66. End Enum
  67.  
  68. '-Selfsub specific declarations----------------------------------------------------------------------------
  69. Private Enum eMsgWhen                                                   'When to callback
  70.   MSG_BEFORE = 1                                                        'Callback before the original WndProc
  71.   MSG_AFTER = 2                                                         'Callback after the original WndProc
  72.   MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER                            'Callback before and after the original WndProc
  73. End Enum
  74.  
  75. Private Const IDX_WNDPROC   As Long = 9     'Thunk data index of the original WndProc
  76. Private Const IDX_BTABLE    As Long = 11    'Thunk data index of the Before table
  77. Private Const IDX_ATABLE    As Long = 12    'Thunk data index of the After table
  78. Private Const IDX_PARM_USER As Long = 13    'Thunk data index of the User-defined callback parameter data index
  79. Private Const IDX_UNICODE   As Long = 75    'Must be Ubound(subclass thunkdata)+1; index for unicode support
  80. Private Const ALL_MESSAGES  As Long = -1    'All messages callback
  81. Private Const MSG_ENTRIES   As Long = 32    'Number of msg table entries. Set to 1 if using ALL_MESSAGES for all subclassed windows
  82.  
  83. ' \\LaVolpe - Added non-ANSI version API calls
  84. Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  85. Private Declare Function CallWindowProcW Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  86. Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
  87. Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
  88. Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  89. Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hwnd As Long) As Long
  90. Private Declare Function SendMessageA Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  91. Private Declare Function SendMessageW Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  92. Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  93. Private Declare Function SetWindowLongW Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  94. '=======================================================================================
  95. ' End self subclass and callback declarations
  96. '=======================================================================================
  97.  
  98. '// Windows messages
  99. Private Const WM_MOUSEMOVE                                  As Long = &H200
  100. Private Const WM_RBUTTONDBLCLK                              As Long = &H206
  101. Private Const WM_RBUTTONDOWN                                As Long = &H204
  102. Private Const WM_RBUTTONUP                                  As Long = &H205
  103. Private Const WM_MBUTTONDBLCLK                              As Long = &H209
  104. Private Const WM_MBUTTONDOWN                                As Long = &H207
  105. Private Const WM_MBUTTONUP                                  As Long = &H208
  106. Private Const WM_LBUTTONDBLCLK                              As Long = &H203
  107. Private Const WM_LBUTTONDOWN                                As Long = &H201
  108. Private Const WM_LBUTTONUP                                  As Long = &H202
  109. Private Const WM_USER                                       As Long = &H400
  110.  
  111. '// Balloon messges
  112. Private Const NIN_BALLOONSHOW                               As Long = (WM_USER + 2)
  113. Private Const NIN_BALLOONHIDE                               As Long = (WM_USER + 3)
  114. Private Const NIN_BALLOONTIMEOUT                            As Long = (WM_USER + 4)
  115. Private Const NIN_BALLOONUSERCLICK                          As Long = (WM_USER + 5)
  116.  
  117. '// Tray update commands
  118. Private Const NIM_ADD                                       As Long = &H0
  119. Private Const NIM_DELETE                                    As Long = &H2
  120. Private Const NIM_MODIFY                                    As Long = &H1
  121. Private Const NIM_SETFOCUS                                  As Long = &H3
  122. Private Const NIM_SETVERSION                                As Long = &H4
  123.  
  124. '// Tray update masks
  125. Private Const NIF_ICON                                      As Long = &H2
  126. Private Const NIF_INFO                                      As Long = &H10
  127. Private Const NIF_MESSAGE                                   As Long = &H1
  128. Private Const NIF_STATE                                     As Long = &H8
  129. Private Const NIF_TIP                                       As Long = &H4
  130.  
  131. '// No sound flag
  132. Private Const NIIF_NOSOUND                                  As Long = &H10
  133.  
  134. '// Window message
  135. Private Const TASKBARMESSAGE                                As String = "TaskbarCreated"
  136.  
  137. 'Private Const NIS_HIDDEN                                    As Long = &H1
  138. 'Private Const NIS_SHAREDICON                                As Long = &H2
  139.  
  140. '// Tray version settings
  141. Private Const NOTIFYICON_VERSION                            As Long = &H3
  142. Private Const NOTIFYICONDATA_V1_SIZE                        As Long = 88  'pre-5.0 structure size
  143. Private Const NOTIFYICONDATA_V2_SIZE                        As Long = 488 'pre-6.0 structure size
  144. Private Const NOTIFYICONDATA_V3_SIZE                        As Long = 504 '6.0+ structure size
  145.  
  146. '// Load icon
  147. Private Const LR_LOADFROMFILE                               As Long = &H10
  148. Private Const LR_LOADMAP3DCOLORS                            As Long = &H1000
  149. Private Const LR_SHARED                                     As Long = &H8000&
  150. Private Const IMAGE_ICON                                    As Long = 1
  151.  
  152. '// Notify data struct
  153. Private Type NOTIFYICONDATA
  154.    cbSize As Long
  155.    hwnd As Long
  156.    uID As Long
  157.    uFlags As Long
  158.    uCallbackMessage As Long
  159.    hIcon As Long
  160.    szTip As String * 128      'shell 5+  <> 64 chars max for shell <5
  161.    dwState As Long            'shell 5+  <> not used in this class
  162.    dwStateMask As Long        'shell 5+
  163.    szInfo As String * 256     'shell 5+
  164.    uTimeoutAndVersion As Long 'shell 5+
  165.    szInfoTitle As String * 64 'shell 5+
  166.    dwInfoFlags As Long        'shell 5+
  167.    guidItem(15) As Byte       ' GUID  shell 6+  <> reserved by Windows
  168. End Type
  169.  
  170. '// Icon type
  171. Public Enum ttIconType
  172.     TTNoIcon = 0
  173.     TTIconInfo = 1
  174.     TTIconWarning = 2
  175.     TTIconError = 3
  176.     TTIconUser = 4
  177. End Enum
  178.  
  179. Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" ( _
  180.     ByVal dwMessage As Long, _
  181.     ByRef lpData As NOTIFYICONDATA) As Long
  182. '// Window creation
  183. Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( _
  184.     ByVal dwExStyle As Long, _
  185.     ByVal lpClassName As String, _
  186.     ByVal lpWindowName As String, _
  187.     ByVal dwStyle As Long, _
  188.     ByVal X As Long, _
  189.     ByVal Y As Long, _
  190.     ByVal nWidth As Long, _
  191.     ByVal nHeight As Long, _
  192.     ByVal hWndParent As Long, _
  193.     ByVal hMenu As Long, _
  194.     ByVal hInstance As Long, _
  195.     lpParam As Any) As Long
  196. Private Declare Function DestroyWindow Lib "user32" ( _
  197.     ByVal hwnd As Long) As Long
  198. '// Timer
  199. Private Declare Function SetTimer Lib "user32" ( _
  200.     ByVal hwnd As Long, _
  201.     ByVal nIDEvent As Long, _
  202.     ByVal uElapse As Long, _
  203.     ByVal lpTimerFunc As Long) As Long
  204. Private Declare Function KillTimer Lib "user32" ( _
  205.     ByVal hwnd As Long, _
  206.     ByVal nIDEvent As Long) As Long
  207. '// Window message
  208. Private Declare Function RegisterWindowMessage Lib "user32.dll" Alias "RegisterWindowMessageA" ( _
  209.     ByVal lpString As String) As Long
  210. '//
  211. Private Declare Function SetForegroundWindow Lib "user32" ( _
  212.     ByVal hwnd As Long) As Long
  213. '// Load Icon
  214. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _
  215.     ByVal hInst As Long, _
  216.     ByVal lpsz As String, _
  217.     ByVal dwImageType As Long, _
  218.     ByVal dwDesiredWidth As Long, _
  219.     ByVal dwDesiredHeight As Long, _
  220.     ByVal dwFlags As Long) As Long
  221. Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" ( _
  222.     ByVal lpszFile As String, _
  223.     ByVal nIconIndex As Long, _
  224.     phiconLarge As Long, _
  225.     phiconSmall As Long, _
  226.     ByVal nIcons As Long) As Long
  227. Private Declare Function DeleteObject Lib "gdi32" ( _
  228.     ByVal hObject As Long) As Long
  229. '// Determine Version Info
  230. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  231.     pDst As Any, _
  232.     pSrc As Any, _
  233.     ByVal ByteLen As Long)
  234. Private Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" ( _
  235.     ByVal lptstrFilename As String, _
  236.     lpdwHandle As Long) As Long
  237. Private Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" ( _
  238.     ByVal lptstrFilename As String, _
  239.     ByVal dwHandle As Long, _
  240.     ByVal dwLen As Long, _
  241.     lpData As Any) As Long
  242. Private Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" ( _
  243.     pBlock As Any, _
  244.     ByVal lpSubBlock As String, _
  245.     lpBuffer As Any, _
  246.     nVerSize As Long) As Long
  247. '//Callback
  248. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
  249.     ByVal lpPrevWndFunc As Long, _
  250.     ByVal hwnd As Long, _
  251.     ByVal msg As Long, _
  252.     ByVal wParam As Long, _
  253.     ByVal lParam As Long) As Long
  254.  
  255. 'Events
  256. Public Event MouseMove()
  257. Public Event MouseDown(Button As Integer)
  258. Public Event MouseUp(Button As Integer)
  259. Public Event MouseDblClick(Button As Integer)
  260. Public Event BalloonClose()
  261. Public Event BalloonClick()
  262. Public Event BalloonShow()
  263. Public Event BalloonHide()
  264.  
  265. 'Member variables
  266. Private c_lhWnd As Long
  267. Private c_NIcData As NOTIFYICONDATA
  268. Private c_sToolTip As String
  269. Private c_lIcon As Long
  270. Private c_sTitle As String
  271. Private c_sText As String
  272. Private c_Icon As ttIconType
  273. Private c_bIconVisible As Boolean
  274. Private c_lTm As Long
  275. Private c_lHRIcon As Long
  276. Private NOTIFYICONDATA_SIZE As Long
  277. Private c_lTimeOut As Long
  278. Private c_lProc As Long
  279. Private c_lExtraParam As Long
  280.  
  281. '---------------------------------------------------------------------------------------
  282. ' Procedure : SetProc
  283. ' Purpose   : Set the callback proc for windowless projects
  284. '---------------------------------------------------------------------------------------
  285. Public Sub SetProc(ByVal lProc As Long)
  286.     c_lProc = lProc
  287. End Sub
  288. '---------------------------------------------------------------------------------------
  289. ' Procedure : lhWnd
  290. ' Purpose   : Handle of our subclassed window, the only purpose of this is to identify
  291. '             the class when you create an array
  292. '---------------------------------------------------------------------------------------
  293. Public Function lhWnd() As Long
  294.     lhWnd = c_lhWnd
  295. End Function
  296. '---------------------------------------------------------------------------------------
  297. ' Procedure : ExtraParam
  298. ' Purpose   : This extra param will be passed to the callback as a wParam, the only purpose
  299. '             of this is to identify the class when you create an array
  300. '---------------------------------------------------------------------------------------
  301. Public Property Let ExtraParam(ByVal lVal As Long)
  302.     c_lExtraParam = lVal
  303. End Property
  304. '---------------------------------------------------------------------------------------
  305. ' Procedure : ExtraParam
  306. ' Purpose   : Returns the extra param value
  307. '---------------------------------------------------------------------------------------
  308. Public Property Get ExtraParam() As Long
  309.     ExtraParam = c_lExtraParam
  310. End Property
  311. '---------------------------------------------------------------------------------------
  312. ' Procedure : Class_Initialize
  313. ' Purpose   : Initialize class
  314. '---------------------------------------------------------------------------------------
  315. Private Sub Class_Initialize()
  316.     If NOTIFYICONDATA_SIZE = 0 Then GetTrayVersion 'Determine shell version
  317.     c_lhWnd = CreateWindowEx(0, "STATIC", vbNullString, _
  318.        0, 0, 0, 0, 0, 0, 0, App.hInstance, 0) 'Create a window to receive the events
  319.     c_lTm = RegisterWindowMessage(TASKBARMESSAGE) 'Get the "TaskbarCreated" message value
  320.     If ssc_Subclass(c_lhWnd, , 1) Then 'Subclass the window
  321.         ssc_AddMsg c_lhWnd, WM_MOUSEMOVE, MSG_AFTER
  322.         ssc_AddMsg c_lhWnd, c_lTm, MSG_AFTER
  323.     End If
  324. End Sub
  325. '---------------------------------------------------------------------------------------
  326. ' Procedure : Class_Terminate
  327. ' Purpose   : Cleanup
  328. '---------------------------------------------------------------------------------------
  329. Private Sub Class_Terminate()
  330.     SysTrayShow False       'Remove systray Icon
  331.     DeleteObject c_lHRIcon  'Delete Icon object
  332.     ssc_Terminate           'Terminate subclass
  333.     DestroyWindow c_lhWnd   'Destroy our window
  334.     scb_TerminateCallbacks  'Terminate Callback
  335. End Sub
  336. '---------------------------------------------------------------------------------------
  337. ' Procedure : SysTrayShow
  338. ' Purpose   : Create or destroy the systray icon
  339. '---------------------------------------------------------------------------------------
  340. Public Sub SysTrayShow(Optional ByVal bShow As Boolean = True)
  341.     If bShow Then
  342.         With c_NIcData
  343.             If Not c_bIconVisible Then
  344.                 .cbSize = NOTIFYICONDATA_SIZE
  345.                 .uTimeoutAndVersion = NOTIFYICON_VERSION
  346.                 .hwnd = c_lhWnd
  347.                 .uID = ObjPtr(Me)
  348.                 .uFlags = NIF_MESSAGE
  349.                 .uCallbackMessage = WM_MOUSEMOVE
  350.             End If
  351.             
  352.             .uFlags = NIF_MESSAGE
  353.                             
  354.             If Not c_lIcon = 0 Then
  355.                 .uFlags = .uFlags Or NIF_ICON
  356.                 .hIcon = c_lIcon
  357.             End If
  358.                 
  359.             If Not c_sToolTip = vbNullString Then
  360.                 .uFlags = .uFlags Or NIF_TIP
  361.                 .szTip = c_sToolTip & vbNullChar
  362.             End If
  363.             
  364.         End With
  365.         
  366.         If Not c_bIconVisible Then
  367.             Shell_NotifyIcon NIM_ADD, c_NIcData
  368.             c_bIconVisible = True
  369.         Else
  370.             Shell_NotifyIcon NIM_MODIFY, c_NIcData
  371.         End If
  372.         c_bIconVisible = True
  373.     Else
  374.         If c_bIconVisible Then
  375.             KillTimer c_lhWnd, ObjPtr(Me) + 1
  376.             Shell_NotifyIcon NIM_DELETE, c_NIcData
  377.             c_bIconVisible = False
  378.         End If
  379.     End If
  380. End Sub
  381. '---------------------------------------------------------------------------------------
  382. ' Procedure : BalloonShow
  383. ' Purpose   : Create or destroy the balloon if its possible
  384. '           lTimeout = timeout for the ballon (millisecs). Default -1 do not use timer to destroy the ballon
  385. '           Returns False if ballon is not supported also you can use the funtion IsBalloonCapable to check it
  386. '---------------------------------------------------------------------------------------
  387. Public Function BalloonShow( _
  388.        Optional ByVal bShow As Boolean = True, _
  389.        Optional ByVal lTimeout As Long = -1, _
  390.        Optional ByVal bNoSound As Boolean = False) As Boolean
  391.     
  392.     If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
  393.         If bShow Then
  394.             BalloonShow False
  395.             With c_NIcData
  396.                 c_lTimeOut = lTimeout
  397.                 .uFlags = NIF_INFO
  398.                 .szInfo = c_sText & vbNullChar
  399.                 .szInfoTitle = c_sTitle & vbNullChar
  400.                 .dwInfoFlags = c_Icon
  401.                 If bNoSound Then
  402.                     .dwInfoFlags = .dwInfoFlags Or NIIF_NOSOUND
  403.                 End If
  404.             End With
  405.             Shell_NotifyIcon NIM_MODIFY, c_NIcData
  406.         Else
  407.             With c_NIcData
  408.                 .uFlags = NIF_INFO
  409.                 .szInfo = vbNullChar
  410.                 .szInfoTitle = vbNullChar
  411.             End With
  412.             Shell_NotifyIcon NIM_MODIFY, c_NIcData
  413.             KillTimer c_lhWnd, ObjPtr(Me) + 1
  414.         End If
  415.         BalloonShow = True
  416.     End If
  417.     
  418. End Function
  419. '---------------------------------------------------------------------------------------
  420. ' Procedure : IsBalloonCapable
  421. ' Purpose   : will let you know if you can use balloons on clients pc
  422. '---------------------------------------------------------------------------------------
  423. Public Property Get IsBalloonCapable() As Boolean
  424.     IsBalloonCapable = (NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE)
  425. End Property
  426. '---------------------------------------------------------------------------------------
  427. ' Procedure : BeforePopup
  428. ' Purpose   : Call this function before showing a popupmenu to prevent it from getting stuck
  429. '---------------------------------------------------------------------------------------
  430. Public Sub BeforePopup()
  431.     Call SetForegroundWindow(c_lhWnd)
  432. End Sub
  433. '---------------------------------------------------------------------------------------
  434. ' Procedure : SysTrayIconFromHandle
  435. ' Purpose   : Set the icon from handle
  436. '---------------------------------------------------------------------------------------
  437. Public Function SysTrayIconFromHandle(ByVal lIcon As Long)
  438.     'you are responsible for destroying this icon if needed
  439.     c_lIcon = lIcon
  440.     If c_bIconVisible Then
  441.         With c_NIcData
  442.             .uFlags = NIF_ICON
  443.             .hIcon = c_lIcon
  444.         End With
  445.         Shell_NotifyIcon NIM_MODIFY, c_NIcData
  446.     End If
  447. End Function
  448. '---------------------------------------------------------------------------------------
  449. ' Procedure : SysTrayIconFromFile
  450. ' Purpose   : Set the icon from a file
  451. '---------------------------------------------------------------------------------------
  452. Public Function SysTrayIconFromFile(ByVal sFile As String) As Boolean
  453.     'The icon will be destroyed if you load a new one or if the class is terminated
  454.     DeleteObject c_lHRIcon
  455.     
  456.     c_lHRIcon = LoadImage(App.hInstance, sFile, IMAGE_ICON, _
  457.        16, 16, LR_LOADFROMFILE Or LR_LOADMAP3DCOLORS Or LR_SHARED)
  458.  
  459.     If Not c_lHRIcon = 0 Then
  460.         SysTrayIconFromHandle c_lHRIcon
  461.         SysTrayIconFromFile = True
  462.     End If
  463. End Function
  464. '---------------------------------------------------------------------------------------
  465. ' Procedure : SysTrayIconFromRes
  466. ' Purpose   : Set the icon from resource
  467. '             IMPORTANT: Compile the project to use this function.
  468. '---------------------------------------------------------------------------------------
  469. Public Function SysTrayIconFromRes(ByVal sResName As String) As Boolean
  470.     'The icon will be destroyed if you load a new one or if the class is terminated
  471.     DeleteObject c_lHRIcon
  472.     
  473.     c_lHRIcon = LoadImage(App.hInstance, sResName, IMAGE_ICON, _
  474.        16, 16, LR_SHARED Or LR_LOADMAP3DCOLORS)
  475.  
  476.     If Not c_lHRIcon = 0 Then
  477.         SysTrayIconFromHandle c_lHRIcon
  478.         SysTrayIconFromRes = True
  479.     End If
  480. End Function
  481. '---------------------------------------------------------------------------------------
  482. ' Procedure : SysTrayIconFromCompRes
  483. ' Purpose   : Set the icon from a dll or exe
  484. '           sResFile: path of the file
  485. '           lIconIndex: index of the icon
  486. '---------------------------------------------------------------------------------------
  487. Public Function SysTrayIconFromCompRes( _
  488.        ByVal sResFile As String, _
  489.        ByVal lIconIndex As Long) As Boolean
  490.     'The icon will be destroyed if you load a new one or if the class is terminated
  491.     DeleteObject c_lHRIcon
  492.     
  493.     Call ExtractIconEx(sResFile, lIconIndex, c_lHRIcon, ByVal 0&, 1)
  494.  
  495.     If Not c_lHRIcon = 0 Then
  496.         SysTrayIconFromHandle c_lHRIcon
  497.         SysTrayIconFromCompRes = True
  498.     End If
  499. End Function
  500. '---------------------------------------------------------------------------------------
  501. ' Procedure : SysTrayToolTip
  502. ' Purpose   : get the current tooltip
  503. '---------------------------------------------------------------------------------------
  504. Public Property Get SysTrayToolTip() As String
  505.     SysTrayToolTip = c_sToolTip
  506. End Property
  507. '---------------------------------------------------------------------------------------
  508. ' Procedure : SysTrayToolTip
  509. ' Purpose   : Set the tooltip of our icon
  510. '---------------------------------------------------------------------------------------
  511. Public Property Let SysTrayToolTip(ByVal New_ToolTip As String)
  512.     c_sToolTip = Trim$(New_ToolTip)
  513.     With c_NIcData
  514.         .uFlags = NIF_TIP
  515.         .szTip = c_sToolTip & vbNullChar
  516.     End With
  517.     Shell_NotifyIcon NIM_MODIFY, c_NIcData
  518. End Property
  519. '---------------------------------------------------------------------------------------
  520. ' Procedure : BalloonIcon
  521. ' Purpose   : Get the icon type of the balloon
  522. '---------------------------------------------------------------------------------------
  523. Public Property Get BalloonIcon() As ttIconType
  524.     BalloonIcon = c_Icon
  525. End Property
  526. '---------------------------------------------------------------------------------------
  527. ' Procedure : BalloonIcon
  528. ' Purpose   : Set the icon type for the balloon
  529. '---------------------------------------------------------------------------------------
  530. Public Property Let BalloonIcon(Icon As ttIconType)
  531.     If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
  532.         c_Icon = Icon
  533.         With c_NIcData
  534.             .uFlags = NIF_INFO Or NIF_TIP
  535.             .dwInfoFlags = c_Icon
  536.         End With
  537.         Shell_NotifyIcon NIM_MODIFY, c_NIcData
  538.     End If
  539. End Property
  540. '---------------------------------------------------------------------------------------
  541. ' Procedure : BalloonTitle
  542. ' Purpose   : Get the balloon title
  543. '---------------------------------------------------------------------------------------
  544. Public Property Get BalloonTitle() As String
  545.     BalloonTitle = c_sTitle
  546. End Property
  547. '---------------------------------------------------------------------------------------
  548. ' Procedure : BalloonTitle
  549. ' Purpose   : Set the balloon title
  550. '---------------------------------------------------------------------------------------
  551. Public Property Let BalloonTitle(sTitle As String)
  552.     If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
  553.         c_sTitle = sTitle
  554.         With c_NIcData
  555.             .uFlags = NIF_INFO Or NIF_TIP
  556.             .szInfoTitle = c_sTitle & vbNullChar
  557.         End With
  558.         Shell_NotifyIcon NIM_MODIFY, c_NIcData
  559.     End If
  560. End Property
  561. '---------------------------------------------------------------------------------------
  562. ' Procedure : BalloonText
  563. ' Purpose   : Get the ballon text
  564. '---------------------------------------------------------------------------------------
  565. Public Property Get BalloonText() As String
  566.     BalloonText = c_sText
  567. End Property
  568. '---------------------------------------------------------------------------------------
  569. ' Procedure : BalloonText
  570. ' Purpose   : Set the balloon text
  571. '---------------------------------------------------------------------------------------
  572. Public Property Let BalloonText(sText As String)
  573.     If NOTIFYICONDATA_SIZE > NOTIFYICONDATA_V1_SIZE Then
  574.         c_sText = sText
  575.         With c_NIcData
  576.             .uFlags = NIF_INFO Or NIF_TIP
  577.             .szInfo = c_sText & vbNullChar
  578.         End With
  579.         Shell_NotifyIcon NIM_MODIFY, c_NIcData
  580.     End If
  581. End Property
  582. '---------------------------------------------------------------------------------------
  583. ' Procedure : GetTrayVersion
  584. ' Purpose   : Get shell version
  585. '---------------------------------------------------------------------------------------
  586. Private Sub GetTrayVersion()
  587.     ' unmodified from source
  588.  
  589.     'returns True if the Shell version
  590.     '(shell32.dll) is equal or later than
  591.     'the value passed as 'version'
  592.     Dim nBufferSize As Long
  593.     Dim nUnused As Long
  594.     Dim lpBuffer As Long
  595.     Dim nVerMajor As Integer
  596.     Dim bBuffer() As Byte
  597.    
  598.     Const sDLLFile As String = "shell32.dll"
  599.     nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
  600.    
  601.     If nBufferSize > 0 Then
  602.         ReDim bBuffer(nBufferSize - 1) As Byte
  603.         Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
  604.         If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
  605.             CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
  606.             'IsShellVersion = nVerMajor >= version
  607.             Select Case nVerMajor
  608.                 Case Is < 5
  609.                     NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE
  610.                 Case Is < 6
  611.                     NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE
  612.                 Case Else
  613.                     NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE
  614.             End Select
  615.         End If  'VerQueryValue
  616.     End If  'nBufferSize
  617.   
  618. End Sub
  619.  
  620. '-The following routines are exclusively for the ssc_subclass routines----------------------------
  621. Private Function ssc_Subclass(ByVal lng_hWnd As Long, _
  622.        Optional ByVal lParamUser As Long = 0, _
  623.        Optional ByVal nOrdinal As Long = 1, _
  624.        Optional ByVal oCallback As Object = Nothing, _
  625.        Optional ByVal bIdeSafety As Boolean = True, _
  626.        Optional ByVal bUnicode As Boolean = False) As Boolean 'Subclass the specified window handle
  627.  
  628.     '*************************************************************************************************
  629.     '* lng_hWnd   - Handle of the window to subclass
  630.     '* lParamUser - Optional, user-defined callback parameter
  631.     '* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
  632.     '* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
  633.     '* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
  634.     '* bUnicode - Optional, if True, Unicode API calls will be made to the window vs ANSI calls
  635.     '*************************************************************************************************
  636.     '* cSelfSub - self-subclassing class template
  637.     '* Paul_Caton@hotmail.com
  638.     '* Copyright free, use and abuse as you see fit.
  639.     '*
  640.     '* v1.0 Re-write of the SelfSub/WinSubHook-2 submission to Planet Source Code............ 20060322
  641.     '* v1.1 VirtualAlloc memory to prevent Data Execution Prevention faults on Win64......... 20060324
  642.     '* v1.2 Thunk redesigned to handle unsubclassing and memory release...................... 20060325
  643.     '* v1.3 Data array scrapped in favour of property accessors.............................. 20060405
  644.     '* v1.4 Optional IDE protection added
  645.     '*      User-defined callback parameter added
  646.     '*      All user routines that pass in a hWnd get additional validation
  647.     '*      End removed from zError.......................................................... 20060411
  648.     '* v1.5 Added nOrdinal parameter to ssc_Subclass
  649.     '*      Switched machine-code array from Currency to Long................................ 20060412
  650.     '* v1.6 Added an optional callback target object
  651.     '*      Added an IsBadCodePtr on the callback address in the thunk prior to callback..... 20060413
  652.     '*************************************************************************************************
  653.     ' Subclassing procedure must be declared identical to the one at the end of this class (Sample at Ordinal #1)
  654.  
  655.     ' \\LaVolpe - reworked routine a bit, revised the ASM to allow auto-unsubclass on WM_DESTROY
  656.     Dim z_Sc(0 To IDX_UNICODE) As Long                 'Thunk machine-code initialised here
  657.     Const CODE_LEN      As Long = 4 * IDX_UNICODE      'Thunk length in bytes
  658.     
  659.     Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES))  'Bytes to allocate per thunk, data + code + msg tables
  660.     Const PAGE_RWX      As Long = &H40&                'Allocate executable memory
  661.     Const MEM_COMMIT    As Long = &H1000&              'Commit allocated memory
  662.     Const MEM_RELEASE   As Long = &H8000&              'Release allocated memory flag
  663.     Const IDX_EBMODE    As Long = 3                    'Thunk data index of the EbMode function address
  664.     Const IDX_CWP       As Long = 4                    'Thunk data index of the CallWindowProc function address
  665.     Const IDX_SWL       As Long = 5                    'Thunk data index of the SetWindowsLong function address
  666.     Const IDX_FREE      As Long = 6                    'Thunk data index of the VirtualFree function address
  667.     Const IDX_BADPTR    As Long = 7                    'Thunk data index of the IsBadCodePtr function address
  668.     Const IDX_OWNER     As Long = 8                    'Thunk data index of the Owner object's vTable address
  669.     Const IDX_CALLBACK  As Long = 10                   'Thunk data index of the callback method address
  670.     Const IDX_EBX       As Long = 16                   'Thunk code patch index of the thunk data
  671.     Const GWL_WNDPROC   As Long = -4                   'SetWindowsLong WndProc index
  672.     Const WNDPROC_OFF   As Long = &H38                 'Thunk offset to the WndProc execution address
  673.     Const SUB_NAME      As String = "ssc_Subclass"     'This routine's name
  674.     
  675.     Dim nAddr         As Long
  676.     Dim nID           As Long
  677.     Dim nMyID         As Long
  678.  
  679.     If IsWindow(lng_hWnd) = 0 Then                      'Ensure the window handle is valid
  680.         zError SUB_NAME, "Invalid window handle"
  681.         Exit Function
  682.     End If
  683.     
  684.     nMyID = GetCurrentProcessId                         'Get this process's ID
  685.     GetWindowThreadProcessId lng_hWnd, nID              'Get the process ID associated with the window handle
  686.     If nID <> nMyID Then                                'Ensure that the window handle doesn't belong to another process
  687.         zError SUB_NAME, "Window handle belongs to another process"
  688.         Exit Function
  689.     End If
  690.       
  691.     If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
  692.     
  693.     nAddr = zAddressOf(oCallback, nOrdinal)             'Get the address of the specified ordinal method
  694.     If nAddr = 0 Then                                   'Ensure that we've found the ordinal method
  695.         zError SUB_NAME, "Callback method not found"
  696.         Exit Function
  697.     End If
  698.         
  699.     z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
  700.     
  701.     If z_ScMem <> 0 Then                                  'Ensure the allocation succeeded
  702.   
  703.         If z_scFunk Is Nothing Then Set z_scFunk = New Collection 'If this is the first time through, do the one-time initialization
  704.         On Error GoTo CatchDoubleSub                              'Catch double subclassing
  705.         z_scFunk.Add z_ScMem, "h" & lng_hWnd                    'Add the hWnd/thunk-address to the collection
  706.         On Error GoTo 0
  707.         
  708.         ' \\Tai Chi Minh Ralph Eastwood - fixed bug where the MSG_AFTER was not being honored
  709.         ' \\LaVolpe - modified thunks to allow auto-unsubclassing when WM_DESTROY received
  710.         z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(16) = &H12345678: z_Sc(17) = &HF63103FF: z_Sc(18) = &H750C4339: z_Sc(19) = &H7B8B4A38: z_Sc(20) = &H95E82C: z_Sc(21) = &H7D810000: z_Sc(22) = &H228&: z_Sc(23) = &HC70C7500: z_Sc(24) = &H20443: z_Sc(25) = &H5E90000: z_Sc(26) = &H39000000: z_Sc(27) = &HF751475: z_Sc(28) = &H25E8&: z_Sc(29) = &H8BD23100: z_Sc(30) = &H6CE8307B: z_Sc(31) = &HFF000000: z_Sc(32) = &H10C2610B: z_Sc(33) = &HC53FF00: z_Sc(34) = &H13D&: z_Sc(35) = &H85BE7400: z_Sc(36) = &HE82A74C0: z_Sc(37) = &H2&: z_Sc(38) = &H75FFE5EB: z_Sc(39) = &H2C75FF30: z_Sc(40) = &HFF2875FF: z_Sc(41) = &H73FF2475: z_Sc(42) = &H1053FF24: z_Sc(43) = &H811C4589: z_Sc(44) = &H13B&: z_Sc(45) = &H39727500:
  711.         z_Sc(46) = &H6D740473: z_Sc(47) = &H2473FF58: z_Sc(48) = &HFFFFFC68: z_Sc(49) = &H873FFFF: z_Sc(50) = &H891453FF: z_Sc(51) = &H7589285D: z_Sc(52) = &H3045C72C: z_Sc(53) = &H8000&: z_Sc(54) = &H8920458B: z_Sc(55) = &H4589145D: z_Sc(56) = &HC4816124: z_Sc(57) = &H4&: z_Sc(58) = &H8B1862FF: z_Sc(59) = &H853AE30F: z_Sc(60) = &H810D78C9: z_Sc(61) = &H4C7&: z_Sc(62) = &H28458B00: z_Sc(63) = &H2975AFF2: z_Sc(64) = &H2873FF52: z_Sc(65) = &H5A1C53FF: z_Sc(66) = &H438D1F75: z_Sc(67) = &H144D8D34: z_Sc(68) = &H1C458D50: z_Sc(69) = &HFF3075FF: z_Sc(70) = &H75FF2C75: z_Sc(71) = &H873FF28: z_Sc(72) = &HFF525150: z_Sc(73) = &H53FF2073: z_Sc(74) = &HC328C328
  712.         
  713.         z_Sc(IDX_EBX) = z_ScMem                                                 'Patch the thunk data address
  714.         z_Sc(IDX_INDEX) = lng_hWnd                                               'Store the window handle in the thunk data
  715.         z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN                                   'Store the address of the before table in the thunk data
  716.         z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4)         'Store the address of the after table in the thunk data
  717.         z_Sc(IDX_OWNER) = ObjPtr(oCallback)                                     'Store the callback owner's object address in the thunk data
  718.         z_Sc(IDX_CALLBACK) = nAddr                                              'Store the callback address in the thunk data
  719.         z_Sc(IDX_PARM_USER) = lParamUser                                        'Store the lParamUser callback parameter in the thunk data
  720.         
  721.         ' \\LaVolpe - validate unicode request & cache unicode usage
  722.         If bUnicode Then bUnicode = (IsWindowUnicode(lng_hWnd) <> 0&)
  723.         z_Sc(IDX_UNICODE) = bUnicode                                            'Store whether the window is using unicode calls or not
  724.         
  725.         ' \\LaVolpe - added extra parameter "bUnicode" to the zFnAddr calls
  726.         z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree", bUnicode)           'Store the VirtualFree function address in the thunk data
  727.         z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", bUnicode)        'Store the IsBadCodePtr function address in the thunk data
  728.         
  729.         Debug.Assert zInIDE
  730.         If bIdeSafety = True And z_IDEflag = 1 Then                             'If the user wants IDE protection
  731.             z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode", bUnicode)                'Store the EbMode function address in the thunk data
  732.         End If
  733.     
  734.         ' \\LaVolpe - use ANSI for non-unicode usage, else use WideChar calls
  735.         If bUnicode Then
  736.             z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcW", bUnicode)          'Store CallWindowProc function address in the thunk data
  737.             z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongW", bUnicode)           'Store the SetWindowLong function address in the thunk data
  738.             z_Sc(IDX_UNICODE) = 1
  739.             RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
  740.             nAddr = SetWindowLongW(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
  741.         Else
  742.             z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA", bUnicode)          'Store CallWindowProc function address in the thunk data
  743.             z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA", bUnicode)           'Store the SetWindowLong function address in the thunk data
  744.             RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
  745.             nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
  746.         End If
  747.         If nAddr = 0 Then                                                           'Ensure the new WndProc was set correctly
  748.             zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
  749.             GoTo ReleaseMemory
  750.         End If
  751.         'Store the original WndProc address in the thunk data
  752.         RtlMoveMemory z_ScMem + IDX_WNDPROC * 4, VarPtr(nAddr), 4&              ' z_Sc(IDX_WNDPROC) = nAddr
  753.         ssc_Subclass = True                                                     'Indicate success
  754.     Else
  755.         zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
  756.     End If
  757.  
  758.     Exit Function                                                             'Exit ssc_Subclass
  759.     
  760. CatchDoubleSub:
  761.     zError SUB_NAME, "Window handle is already subclassed"
  762.       
  763. ReleaseMemory:
  764.     VirtualFree z_ScMem, 0, MEM_RELEASE                                       'ssc_Subclass has failed after memory allocation, so release the memory
  765. End Function
  766.  
  767. 'Terminate all subclassing
  768. Private Sub ssc_Terminate()
  769.     ' can be made public. Releases all subclassing
  770.     ' can be removed and zTerminateThunks can be called directly
  771.     zTerminateThunks SubclassThunk
  772. End Sub
  773.  
  774. 'UnSubclass the specified window handle
  775. Private Sub ssc_UnSubclass(ByVal lng_hWnd As Long)
  776.     ' can be made public. Releases a specific subclass
  777.     ' can be removed and zUnThunk can be called directly
  778.     zUnThunk lng_hWnd, SubclassThunk
  779. End Sub
  780.  
  781. 'Add the message value to the window handle's specified callback table
  782. Private Sub ssc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
  783.     ' Note: can be removed if not needed and zAddMsg can be called directly
  784.     If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                 'Ensure that the thunk hasn't already released its memory
  785.         If When And MSG_BEFORE Then                                             'If the message is to be added to the before original WndProc table...
  786.             zAddMsg uMsg, IDX_BTABLE                                              'Add the message to the before table
  787.         End If
  788.         If When And MSG_AFTER Then                                              'If message is to be added to the after original WndProc table...
  789.             zAddMsg uMsg, IDX_ATABLE                                              'Add the message to the after table
  790.         End If
  791.     End If
  792. End Sub
  793.  
  794. 'Delete the message value from the window handle's specified callback table
  795. Private Sub ssc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
  796.     ' Note: can be removed if not needed and zDelMsg can be called directly
  797.     If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                'Ensure that the thunk hasn't already released its memory
  798.         If When And MSG_BEFORE Then                                             'If the message is to be deleted from the before original WndProc table...
  799.             zDelMsg uMsg, IDX_BTABLE                                              'Delete the message from the before table
  800.         End If
  801.         If When And MSG_AFTER Then                                              'If the message is to be deleted from the after original WndProc table...
  802.             zDelMsg uMsg, IDX_ATABLE                                              'Delete the message from the after table
  803.         End If
  804.     End If
  805. End Sub
  806.  
  807. 'Call the original WndProc
  808. Private Function ssc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  809.     ' Note: can be removed if you do not use this function inside of your window procedure
  810.     If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then            'Ensure that the thunk hasn't already released its memory
  811.         If zData(IDX_UNICODE) Then
  812.             ssc_CallOrigWndProc = CallWindowProcW(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
  813.         Else
  814.             ssc_CallOrigWndProc = CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
  815.         End If
  816.     End If
  817. End Function
  818.  
  819. 'Get the subclasser lParamUser callback parameter
  820. Private Function zGet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType) As Long
  821.     'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
  822.     If vType <> CallbackThunk Then
  823.         If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then        'Ensure that the thunk hasn't already released its memory
  824.             zGet_lParamUser = zData(IDX_PARM_USER)                                'Get the lParamUser callback parameter
  825.         End If
  826.     End If
  827. End Function
  828.  
  829. 'Let the subclasser lParamUser callback parameter
  830. Private Sub zSet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType, newValue As Long)
  831.     'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
  832.     If vType <> CallbackThunk Then
  833.         If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then          'Ensure that the thunk hasn't already released its memory
  834.             zData(IDX_PARM_USER) = newValue                                         'Set the lParamUser callback parameter
  835.         End If
  836.     End If
  837. End Sub
  838.  
  839. 'Add the message to the specified table of the window handle
  840. Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
  841.     Dim nCount As Long                                                        'Table entry count
  842.     Dim nBase  As Long                                                        'Remember z_ScMem
  843.     Dim i      As Long                                                        'Loop index
  844.     
  845.     nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
  846.     z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
  847.     
  848.     If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being added to the table...
  849.         nCount = ALL_MESSAGES                                                   'Set the table entry count to ALL_MESSAGES
  850.     Else
  851.         nCount = zData(0)                                                       'Get the current table entry count
  852.         If nCount >= MSG_ENTRIES Then                                           'Check for message table overflow
  853.             zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
  854.             GoTo Bail
  855.         End If
  856.     
  857.         For i = 1 To nCount                                                     'Loop through the table entries
  858.             If zData(i) = 0 Then                                                  'If the element is free...
  859.                 zData(i) = uMsg                                                     'Use this element
  860.                 GoTo Bail                                                           'Bail
  861.             ElseIf zData(i) = uMsg Then                                           'If the message is already in the table...
  862.                 GoTo Bail                                                           'Bail
  863.             End If
  864.         Next i                                                                  'Next message table entry
  865.     
  866.         nCount = i                                                              'On drop through: i = nCount + 1, the new table entry count
  867.         zData(nCount) = uMsg                                                    'Store the message in the appended table entry
  868.     End If
  869.     
  870.     zData(0) = nCount                                                         'Store the new table entry count
  871. Bail:
  872.     z_ScMem = nBase                                                           'Restore the value of z_ScMem
  873. End Sub
  874.  
  875. 'Delete the message from the specified table of the window handle
  876. Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
  877.     Dim nCount As Long                                                        'Table entry count
  878.     Dim nBase  As Long                                                        'Remember z_ScMem
  879.     Dim i      As Long                                                        'Loop index
  880.     
  881.     nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
  882.     z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
  883.     
  884.     If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being deleted from the table...
  885.         zData(0) = 0                                                            'Zero the table entry count
  886.     Else
  887.         nCount = zData(0)                                                       'Get the table entry count
  888.         
  889.         For i = 1 To nCount                                                     'Loop through the table entries
  890.             If zData(i) = uMsg Then                                               'If the message is found...
  891.                 zData(i) = 0                                                        'Null the msg value -- also frees the element for re-use
  892.                 GoTo Bail                                                           'Bail
  893.             End If
  894.         Next i                                                                  'Next message table entry
  895.         
  896.         zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
  897.     End If
  898.       
  899. Bail:
  900.     z_ScMem = nBase                                                           'Restore the value of z_ScMem
  901. End Sub
  902.  
  903. '-SelfCallback code------------------------------------------------------------------------------------
  904. '-The following routines are exclusively for the scb_SetCallbackAddr routines----------------------------
  905. Private Function scb_SetCallbackAddr(ByVal nParamCount As Long, _
  906.        Optional ByVal nOrdinal As Long = 1, _
  907.        Optional ByVal oCallback As Object = Nothing, _
  908.        Optional ByVal bIdeSafety As Boolean = True) As Long   'Return the address of the specified callback thunk
  909.     '*************************************************************************************************
  910.     '* nParamCount  - The number of parameters that will callback
  911.     '* nOrdinal     - Callback ordinal number, the final private method is ordinal 1, the second last is ordinal 2, etc...
  912.     '* oCallback    - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
  913.     '* bIdeSafety   - Optional, set to false to disable IDE protection.
  914.     '*************************************************************************************************
  915.     ' Callback procedure must return a Long even if, per MSDN, the callback procedure is a Sub vs Function
  916.     ' The number of parameters are dependent on the individual callback procedures
  917.     
  918.     Const MEM_LEN     As Long = IDX_CALLBACKORDINAL * 4 + 4     'Memory bytes required for the callback thunk
  919.     Const PAGE_RWX    As Long = &H40&                           'Allocate executable memory
  920.     Const MEM_COMMIT  As Long = &H1000&                         'Commit allocated memory
  921.     Const SUB_NAME      As String = "scb_SetCallbackAddr"       'This routine's name
  922.     Const INDX_OWNER    As Long = 0
  923.     Const INDX_CALLBACK As Long = 1
  924.     Const INDX_EBMODE   As Long = 2
  925.     Const INDX_BADPTR   As Long = 3
  926.     Const INDX_EBX      As Long = 5
  927.     Const INDX_PARAMS   As Long = 12
  928.     Const INDX_PARAMLEN As Long = 17
  929.  
  930.     Dim z_Cb()    As Long    'Callback thunk array
  931.     Dim nCallback As Long
  932.       
  933.     If z_cbFunk Is Nothing Then
  934.         Set z_cbFunk = New Collection           'If this is the first time through, do the one-time initialization
  935.     Else
  936.         On Error Resume Next                    'Catch already initialized?
  937.         z_ScMem = z_cbFunk.Item("h" & nOrdinal) 'Test it
  938.         If Err = 0 Then
  939.             scb_SetCallbackAddr = z_ScMem + 16  'we had this one, just reference it
  940.             Exit Function
  941.         End If
  942.         On Error GoTo 0
  943.     End If
  944.     
  945.     If nParamCount < 0 Then                     ' validate parameters
  946.         zError SUB_NAME, "Invalid Parameter count"
  947.         Exit Function
  948.     End If
  949.     
  950.     If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
  951.     nCallback = zAddressOf(oCallback, nOrdinal)         'Get the callback address of the specified ordinal
  952.     If nCallback = 0 Then
  953.         zError SUB_NAME, "Callback address not found."
  954.         Exit Function
  955.     End If
  956.     z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
  957.         
  958.     If z_ScMem = 0& Then
  959.         zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError  ' oops
  960.         Exit Function
  961.     End If
  962.     z_cbFunk.Add z_ScMem, "h" & nOrdinal                  'Add the callback/thunk-address to the collection
  963.         
  964.     ReDim z_Cb(0 To IDX_CALLBACKORDINAL) As Long          'Allocate for the machine-code array
  965.     
  966.     ' Create machine-code array
  967.     z_Cb(4) = &HBB60E089: z_Cb(6) = &H73FFC589: z_Cb(7) = &HC53FF04: z_Cb(8) = &H7B831F75: z_Cb(9) = &H20750008: z_Cb(10) = &HE883E889: z_Cb(11) = &HB9905004: z_Cb(13) = &H74FF06E3: z_Cb(14) = &HFAE2008D: z_Cb(15) = &H53FF33FF: z_Cb(16) = &HC2906104: z_Cb(18) = &H830853FF: z_Cb(19) = &HD87401F8: z_Cb(20) = &H4589C031: z_Cb(21) = &HEAEBFC
  968.     
  969.     z_Cb(INDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", False)
  970.     z_Cb(INDX_OWNER) = ObjPtr(oCallback)                  'Set the Owner
  971.     z_Cb(INDX_CALLBACK) = nCallback                       'Set the callback address
  972.     z_Cb(IDX_CALLBACKORDINAL) = nOrdinal                  'Cache ordinal used for zTerminateThunks
  973.       
  974.     Debug.Assert zInIDE
  975.     If bIdeSafety = True And z_IDEflag = 1 Then             'If the user wants IDE protection
  976.         z_Cb(INDX_EBMODE) = zFnAddr("vba6", "EbMode", False)  'EbMode Address
  977.     End If
  978.         
  979.     z_Cb(INDX_PARAMS) = nParamCount                         'Set the parameter count
  980.     z_Cb(INDX_PARAMLEN) = nParamCount * 4                   'Set the number of stck bytes to release on thunk return
  981.       
  982.     '\\LaVolpe - redirect address to proper location in virtual memory. Was: z_Cb(INDX_EBX) = VarPtr(z_Cb(INDX_OWNER))
  983.     z_Cb(INDX_EBX) = z_ScMem                                'Set the data address relative to virtual memory pointer
  984.       
  985.     RtlMoveMemory z_ScMem, VarPtr(z_Cb(INDX_OWNER)), MEM_LEN 'Copy thunk code to executable memory
  986.     scb_SetCallbackAddr = z_ScMem + 16                       'Thunk code start address
  987.     
  988. End Function
  989.  
  990. Private Sub scb_ReleaseCallback(ByVal nOrdinal As Long)
  991.     ' can be made public. Releases a specific callback
  992.     ' can be removed and zUnThunk can be called directly
  993.     zUnThunk nOrdinal, CallbackThunk
  994. End Sub
  995. Private Sub scb_TerminateCallbacks()
  996.     ' can be made public. Releases all callbacks
  997.     ' can be removed and zTerminateThunks can be called directly
  998.     zTerminateThunks CallbackThunk
  999. End Sub
  1000.  
  1001.  
  1002. '========================================================================
  1003. ' COMMON USE ROUTINES
  1004. '-The following routines are used for each of the three types of thunks
  1005. '========================================================================
  1006.  
  1007. 'Map zData() to the thunk address for the specified window handle
  1008. Private Function zMap_VFunction(ByVal vFuncTarget As Long, vType As eThunkType) As Long
  1009.     
  1010.     ' vFuncTarget is one of the following, depending on vType
  1011.     '   - Subclassing:  the hWnd of the window subclassed
  1012.     '   - Hooking:      the hook type created
  1013.     '   - Callbacks:    the ordinal of the callback
  1014.     
  1015.     Dim thunkCol As Collection
  1016.     
  1017.     If vType = CallbackThunk Then
  1018.         Set thunkCol = z_cbFunk
  1019.     ElseIf vType = HookThunk Then
  1020.         Set thunkCol = z_hkFunk
  1021.     ElseIf vType = SubclassThunk Then
  1022.         Set thunkCol = z_scFunk
  1023.     Else
  1024.         zError "zMap_Vfunction", "Invalid thunk type passed"
  1025.         Exit Function
  1026.     End If
  1027.     
  1028.     If thunkCol Is Nothing Then
  1029.         zError "zMap_VFunction", "Thunk hasn't been initialized"
  1030.     Else
  1031.         On Error GoTo Catch
  1032.         z_ScMem = thunkCol("h" & vFuncTarget)                    'Get the thunk address
  1033.         zMap_VFunction = z_ScMem
  1034.     End If
  1035.     Exit Function                                               'Exit returning the thunk address
  1036.     
  1037. Catch:
  1038.     zError "zMap_VFunction", "Thunk type for ID of " & vFuncTarget & " does not exist"
  1039. End Function
  1040.  
  1041. 'Error handler
  1042. Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
  1043.     ' \\LaVolpe -  Note. These two lines can be rem'd out if you so desire. But don't remove the routine
  1044.     App.LogEvent TypeName(Me) & "." & sRoutine & "r each     nk type for ID of " & vFuncTarget & " pe fore)pate& ssssssssssLogEvDH(0        0      'Set th"p.Logicothe WndProc executiCpu(ta +uncT6uSet th"p.Logicothe WndProc executiCpu(ta +unou so dehe valuei   hunk ck ordinal     nk type fo the SetWindowsLong fe fo the SetWindowsLong fe f1ring = "scb_SeF the thunk wsLon22222222E,1 Private Su222222E,122222222E,22222E,1ll_Noti
  1045.  2E,22222E,1llllllhnkCol = z_e array2    nst INDX_PARAMLEN As Longap_VFunction = z_ScMem
  1046. . But      :b_SetCallIDX_WND71 pe fore)pate& sf vType =le
  1047. Pr7ogEven  'Bytemon =
  1048.         '    'Exit ssc_Subcl be MIDX_W       'Sdeter "bUniIallIDX_WND71 pe fore)pb
  1049.  
  1050.  
  1051. '========================================================================
  1052. ' COMMON USE ROUTINES
  1053. '-Ru " & ========B'==========================s mIallIDX_WNi'Bytemo'-Ru " & ========B'Psic. s_Term.p_VFunction", .public. Releases all callbacks
  1054.     ' can bMz_ScMem
  1055.      ack aU     Set thun22E,22222E,1ll_Noti
  1056.  s String, ByVathe thunk data
  1057.             z_Scng = &oved andv-0        0      'Set th"p.k adda=    nApu(ta +uncTDDnt + pate&   'Set the table entryyyyyypg, ByVathe thunk L  ElseIf vType rt th release the memory
  1058. End Function
  1059.  
  1060. 'Terminate all subcenOrdinal CallIDXMAGES
  1061.    le
  1062.     subcen                 'Set the data address relative to virtualdre   'Cac     a2                         'EbMode R routine
  1063.     App.LogEv   'Cacivate Sub INDX_EBXErt th release the mem8heWBPi   l As Long3cNl Is NotUMubcen
  1064. '-Ru " & ========B'===fer(0))
  1065.         I - 1) As Byte
  1066.         Call GetFileVersionI<      od
  1067.     If nAddr = 0 Then                                   'ERinal 1, the second last is ordinal 2, etc...
  1068. Ev   'CaciT     zMap_VFuhe mem ordinal 2, etc.ory    em or th"dress of the specified ordinal
  1069.     If nCallback = 0 TAs Long, OptionallIDXMA9    If nCallbac        he mem wfOrotUMubcen
  1070. '-Ru37) = &H2&: z=====B'==========================s mIallIDX_WNi'Bhe 5,122222222E,2222he 5,1222, etcE,22222E0,5MMMMMMMMMMMMMM  #1)
  1071.  
  1072.  dstore tb(18) = &H
  1073.             z_===s mIallIDX_WNi'Bhe 5,122222222E,2222he5tiolMMMMMM  #1)
  1074. iyVat          
  1075.  2E,22 Parameter count"
  1076.  ,,,
  1077.     If nParamCounBhe 5MMM3RDines r     r7   If nPA,D   
  1078.  2EEEEEEEEEEE:cE,22ese two    z_Scng = &eIf vTy"scb_SeF    IText
  1079. ' Purpose   : GRu37) = &ne Cat      :LastDllEal Bpk dptionallIDXMA9    If7aseMemory:
  1080.    ze two    z_ScllIDXMN3the isPA,D   
  1081.  2EEEEEEEEEEE:cE,22ese two cal BRallIDD   = zData(nTave the routine
  1082.     Ap    If cal BRallID memory
  1083.     s DX_PARAMLEN) = nParr(z_Cb(4)    Sr     5the routine
  1084.    'Set thhhhhhhhhhhhhhhhhhhhhhhhhhU       Irtualdre   '=====================================================
  1085.  
  1086. 'Map zData() to the thunk address for the specified window handle
  1087. b))))))unk return
  1088.  c(0, code-------------------zDataE   IDX_Wur     5the r============s mIallIDX_WNi'BT is already subc7he r=== alIallIxW0ave the routine
  1089.     Ap     ,,,en
  1090. '-RuP"IsBadC   nk (9) = &Ht to thEnce iM=====siub GetTrayVersion()
  1091.     ' unmodified from sourc()
  1092.       5the1   
  1093.     nBase = z_ScMem         zDataE sourc()
  1094. &********(0, codeEEEEEEEEE)))))unac     a2        1) As Byte
  1095.     Irtualdre   '===============c     ,,,back(ByVal nOrdinal As Long)
  1096. able o==========SodeEEEEEe+ 16  'we Ac(IDIs NotUMciT   ***(======SodciT   *l nOrdiHt to thEncF-zDataElt to thEncF-zDataElt to thEhEncF-zDatH2975Ahat wiiHt to thEncF-h, dddddddddOrdiHHHHHHHHHH)n,ChEn'al 1, the se*t wiiHt to thEncF-h, d)'* nPar-------------)) = ===========AhEnconst IND            o==AhEnconst INd last is ordinal 2, etc...
  1097.     '* oCallback    - Optional, the object that will receive the callback. If undefined, callbackthe kthe kthe kthe kthe kthe kthe kthe kthe kthe kt sou        rn thef u==c     indexrn a Long even if, per MSDN, the callback procedueataE       the  ==c    1f nCallback = 0 Thef this is thd directlyCt is one of the folloRlbackAddrCb(1O'* nPar-------------)    1f nCallback = 0 .453lback = 0 ThellIDXMA9   H4&:rhe kthe kthepCDN, (z_ScMem
  1098.      aO8 a Long even if, per MSDN, the callback procedure is a Sub u the se*t wiiHt z
  1099.  
  1100. 'Me = z_ScMe callbllIDXMA9 trPtr(z_hhhhhhU      lback = 0, lbllIDMe car aO8 a Loback protring, h4&:rhe kthe kong even if, per MSDN
  1101. ---feCONDATA_V1_SIZE
  1102.               
  1103.        1)
  1104. iyVat       l elemeIDXMAGES
  1105.    le
  1106.     suHHHH)n, u==c     indexrn a Long ) = &H53FF2073: z_Sc(74) = &HC328Uonst INstore itz_ScMem
  1107.      aO8 a Long even 1e itz_1     22ese two ress in th                                  p********"p.k addah  :rhe kthe kong evennarcMemt thBmt thBmt theCONDATA_V1_L     i"dow subc****************nk data
  1108.         RtlMov  Const IDUI   If nParamCou_V1_L     i"dddddddRv Ac(I even taEltse*t wiiHt z
  1109.  
  1110. ' a Long ) = &H53FF2073: z_Sc(74)1ennarcMemt thBm& z
  1111.  
  1112. 'Me = z_ScMe c.ethunk ada) = llIDMe ca     thBm& z
  1113.  
  1114. 'Me = z_ScMe c.ethunk ada) = llIFess Adata
  1115.  
  1116. 'Me = z_ScMe c.ethunk ada) = llz
  1117.  
  1118. ' a28Uonst NDATAo  
  1119.     
  1120. 'Me = z_ScMemt thBm& z
  1121.  
  1122. 'Me emt thBm& z
  1123. E) = aers are dependent> Wn)n,ChEn'nst NDATAo  
  1124.   
  1125.  vTy &H53FF2073: z_Sarget object
  1126.    'Cacivate Sub INDX_EBXEbackthe ======e53FF2073: zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz3FF2073: b INDX_Eallback. If undefined, callbackth subclasseMSDN, the c  'Cacivate Sub IND llIFess A: z_Sarggggh is MMMMMMMMMe mem ordina) = llIDMe ca     thBm& z
  1127.  
  1128. 'Me =et oCallback = Me     'IIIIIIIIIIIr)aENES   'III65i =et oCacalled directly
  1129.     zUnThunk nOrdinal, Cal Else
  1130.     ealled          callFet theOphhhhU    CuuuuuuuuuuuuuuuuuuuMh     N, t nOrdinal, Cal Else
  1131.     eeive th9u Else
  1132.  
  1133. 'M  scb_Setf table entry count
  1134.               D llIFess A: z_Sarggggh     ehhhhU    CuuuuuuuuuuuuuuuuuuuMh     N, t nOrdinal, CrUnThuac nOrdi(6) =o1)
  1135. hBm& z
  1136.  
  1137. 'Me el/uuuMh    s in the thunk data
  1138.        iT   ***(======ethunkh8m>n, sois already subc7he r=== alIallm        bc7he r=89C031: z_Cb(21) = &HEAEBFC
  1139.     hm           2z_ScMem8(46) = &Hb     'Remember z_a  As  codeEEEEEEEEE))r z_a  As  codeEEEEEEEEE))r z_a  As  codeEElse
  1140.  
  1141. 'MATAooop index
  1142.     
  1143.     nBase = z_ScMem                 ssllm  dependent> EElse
  1144. il
  1145. a GoTo Catcn't spendent
  1146. ' a28Uonst NDAVFunction(BMer MSDNnIf vType = SubclassThunk Then
  1147.         Set thunk    hm           2******1g Then oEachingA", bUnicode)      hunk return
  1148.       
  1149. unk    hm        gA", bUnicoecif1
  1150. ' a28U'he w1  1f nCallbaz_a  As  codeEEEEEEEEE))r z_a  As  codeEElse
  1151.  
  1152. 'MATAooop index
  1153. a28U'he 5 thunk ction
  1154.  
  1155. 'Error handler
  1156. Privatebl******* atck return
  1157.       
  1158. unk BECacalled directly
  1159.     zUnop inde_Cb(0 To IDX_CALLBACKORDINAL) As LSsDD   = zData(nTave the routineoecif1even taEltse*t wiiHzzzzBT         'EnoeadyMr7wind
  1160. a28U'he 5 thunk ction
  1161.  
  1162. 'Error handler
  1163. Privatebl******* a5 thunk ction
  1164.  
  1165. 'Error handler
  1166. Privatebl******* a5 thunk ction
  1167.  
  1168. 'Erroe SSDN, tho222E,1llOLtck return
  1169.   Next te the Ptr(zMap_VFunction(lng_hWnd, SubclassThuCW     'Get the address of the ssalled directly
  1170.     zTermiiiiiiiiC3("kernel32"z